(define (uctmwrl:rem-let-prog prog)
  (define (rem-let-fundef fundef)
    (let ((exp (cadddr fundef))
          (pars (cadr fundef))
          (fname (car fundef)))
      (init-let-var)
      `(,fname ,pars = ,(rem-let-exp exp))))
  (define (rem-let-exp exp)
    (cond ((symbol? exp) exp)
          ((equal? (car exp) 'quote) exp)
          ((equal? (car exp) 'let)
           (let ((exp0 (caddr exp)) (bindings (cadr exp)))
             (let ((bindings (map rem-let-binding bindings))
                   (exp0 (rem-let-exp exp0)))
               (let ((%%12 (look-at-bindings bindings exp0)))
                 (let ((varenv (cdr %%12)) (bindings (car %%12)))
                   (gen-let bindings (substitute exp0 varenv)))))))
          ((let ((fname_exp* (cdr exp)) (&call (car exp)))
             (memq &call '(call rcall xcall)))
           (let ((fname_exp* (cdr exp)) (&call (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               `(,&call ,fname unquote (map rem-let-exp exp*)))))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             `(,op unquote (map rem-let-exp exp*))))))
  (define (rem-let-binding binding)
    (let ((exp (cadr binding)) (vname (car binding)))
      `(,vname ,(rem-let-exp exp))))
  (define (look-at-bindings bindings exp0)
    (let loop ((old-b bindings) (new-b '()) (varenv '()))
      (if (null? old-b)
        `(,(reverse new-b) unquote varenv)
        (let ((rest (cdr old-b))
              (exp (cadar old-b))
              (vname (caar old-b)))
          (if (symbol? exp)
            (loop rest
                  new-b
                  `((,vname unquote exp) unquote varenv))
            (let ((%%13 (max-occurrences vname exp0)))
              (cond ((equal? %%13 0) (loop rest new-b varenv))
                    ((equal? %%13 1)
                     (loop rest
                           new-b
                           `((,vname unquote exp) unquote varenv)))
                    (else
                     (let ((newvar (gen-let-var)))
                       (loop rest
                             `((,newvar ,exp) unquote new-b)
                             `((,vname unquote newvar)
                               unquote
                               varenv)))))))))))
  (define (substitute exp varenv)
    (cond ((let ((vname exp)) (symbol? vname))
           (let ((vname exp))
             (let ((vdescr (assq vname varenv)))
               (if vdescr (cdr vdescr) vname))))
          ((equal? (car exp) 'quote) exp)
          ((equal? (car exp) 'let)
           (let ((exp0 (caddr exp)) (bindings (cadr exp)))
             `(let ,(substitute-bindings bindings varenv)
                ,(substitute exp0 varenv))))
          ((let ((fname_exp* (cdr exp)) (&call (car exp)))
             (memq &call '(call rcall xcall)))
           (let ((fname_exp* (cdr exp)) (&call (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               `(,&call ,fname unquote (substitute* exp* varenv)))))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             `(,op unquote (substitute* exp* varenv))))))
  (define (substitute-bindings bindings varenv)
    (map (lambda (binding)
           (let ((exp (cadr binding)) (vname (car binding)))
             `(,vname ,(substitute exp varenv))))
         bindings))
  (define (substitute* exp* varenv)
    (map (lambda (exp) (substitute exp varenv)) exp*))
  (define (gen-let bindings exp0)
    (if (null? bindings) exp0 `(let ,bindings ,exp0)))
  (define (max-occurrences vname exp)
    (cond ((symbol? exp) (if (eq? vname exp) 1 0))
          ((equal? (car exp) 'quote) 0)
          ((equal? (car exp) 'if)
           (let ((exp2 (cadddr exp))
                 (exp1 (caddr exp))
                 (exp0 (cadr exp)))
             (let ((n0 (max-occurrences vname exp0))
                   (n1 (max-occurrences vname exp1))
                   (n2 (max-occurrences vname exp2)))
               (max (+ n0 n1) (+ n0 n2)))))
          ((equal? (car exp) 'let)
           (let ((exp0 (caddr exp)) (bindings (cadr exp)))
             (let ((n1 (max-occurrences* vname (map cadr bindings)))
                   (n0 (max-occurrences vname exp0)))
               (+ n1 n0))))
          ((let ((fname_exp* (cdr exp)) (&call (car exp)))
             (memq &call '(call rcall xcall)))
           (let ((fname_exp* (cdr exp)) (&call (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               (max-occurrences* vname exp*))))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (max-occurrences* vname exp*)))))
  (define (max-occurrences* vname exp*)
    (foldl-map
      +
      0
      (lambda (exp) (max-occurrences vname exp))
      exp*))
  (define let-var-count #f)
  (define (init-let-var) (set! let-var-count 0))
  (define (gen-let-var)
    (set! let-var-count (+ let-var-count 1))
    (string->symbol
      (string-append
        "$"
        (number->string let-var-count))))
  (map rem-let-fundef prog))

(define (uctmwrl:cut-let-prog prog)
  (define (cut-let-fundef fundef)
    (define aux-funcs #f)
    (define let-func-prefix #f)
    (define let-func-count #f)
    (define (init-let-funcs prefix)
      (set! let-func-prefix
        (string-append (symbol->string prefix) "$/"))
      (set! let-func-count 0))
    (define (gen-let-func)
      (set! let-func-count (+ let-func-count 1))
      (string->symbol
        (string-append
          let-func-prefix
          (number->string let-func-count))))
    (define (cut-let-exp! exp)
      (cond ((let ((vname exp)) (symbol? vname))
             (let ((vname exp)) vname))
            ((equal? (car exp) 'quote) exp)
            ((equal? (car exp) 'let)
             (let ((exp0 (caddr exp)) (bindings (cadr exp)))
               (let* ((b-vars (map car bindings))
                      (b-exps
                        (map (lambda (binding) (cut-let-exp! (cadr binding)))
                             bindings))
                      (exp0 (cut-let-exp! exp0))
                      (free (reverse (free-vars exp0 '() b-vars)))
                      (fname (gen-let-func))
                      (aux `(,fname (,@b-vars ,@free) = ,exp0)))
                 (set! aux-funcs `(,aux unquote aux-funcs))
                 `(call ,fname ,@b-exps ,@free))))
            ((let ((fname_exp* (cdr exp)) (&call (car exp)))
               (memq &call '(call rcall xcall)))
             (let ((fname_exp* (cdr exp)) (&call (car exp)))
               (let ((exp* (cdr fname_exp*))
                     (fname (car fname_exp*)))
                 `(,&call ,fname unquote (map cut-let-exp! exp*)))))
            (else
             (let ((exp* (cdr exp)) (op (car exp)))
               `(,op unquote (map cut-let-exp! exp*))))))
    (let ((exp (cadddr fundef))
          (pars (cadr fundef))
          (fname (car fundef)))
      (init-let-funcs fname)
      (set! aux-funcs '())
      (let ((exp (cut-let-exp! exp)))
        `((,fname ,pars = ,exp) unquote aux-funcs))))
  (define (free-vars exp free bound)
    (cond ((symbol? exp)
           (if (or (memq exp bound) (memq exp free))
             free
             (cons exp free)))
          ((equal? (car exp) 'quote) free)
          ((let ((fname_exp* (cdr exp)) (&call (car exp)))
             (memq &call '(call rcall xcall)))
           (let ((fname_exp* (cdr exp)) (&call (car exp)))
             (let ((exp* (cdr fname_exp*))
                   (fname (car fname_exp*)))
               (free-vars* exp* free bound))))
          (else
           (let ((exp* (cdr exp)) (op (car exp)))
             (free-vars* exp* free bound)))))
  (define (free-vars* exp* free bound)
    (if (null? exp*)
      free
      (let ((rest (cdr exp*)) (exp (car exp*)))
        (let ((free (free-vars exp free bound)))
          (free-vars* rest free bound)))))
  (append-map cut-let-fundef prog))

